;;; Copyright © 2020 Maxime Devos <maxime.devos@student.kuleuven.be>
;;; This file is part of rehash.
;;;
;;; rehash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; rehash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with rehash.  If not, see <http://www.gnu.org/licenses/>.
(define-module (rehash)
  #:export (load-rehash!
            open-rehash-service close-rehash-service
            rehash-service-connected? rehash-service-reconnect
            store-hash! store-abort!
            ;; todo query
            query! query-abort!
            rehash-handle? rehash-handle->pointer
            query-context? query-context->pointer
            store-context? store-context->pointer
            bytevector->hash hash-type hash-length hash-bv
            HASH_NONE
            HASH_SHA256
            HASH_SHA512
            HASH_SHA3_256
            HASH_SHA3_512
            HASH_BLAKE2S_256
            HASH_FS_REGULAR
            ORIGIN_DHT
            ORIGIN_DATASTORE
            ;; internal usage only!
            delayed-ffi)
  #:use-module (system foreign)
  #:use-module (rnrs base)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (rehash configuration)
  #:use-module (rehash binding-utils)
  #:use-module (rehash fs)
  #:use-module (rehash common))

;; TODO correct
(define %librehash-location
  (string-append (getcwd)
                 "/.libs/librehash.so"))

(define %librehash
  (delay (dynamic-link %librehash-location)))

(define (load-rehash!)
  (force %librehash))

(define (delayed-ffi name return-type arg-types)
  (let ((delayed-proc (delay (pointer->procedure
                              return-type
                              (dynamic-func name (force %librehash))
                              arg-types))))
    (lambda arguments
      (apply (force delayed-proc) arguments))))

(define (aborter name ->pointer -pointer-set!)
  (let ((c:abort! (delayed-ffi name void '(*))))
    (lambda (context)
      (let ((memory (->pointer context)))
        (assert (not (null-pointer? memory)))
        (-pointer-set! context %null-pointer)
        (c:abort! memory)))))

;; TODO what about aborting an active action
;; from a callback
(define-record-type <rehash-handle>
  ;; cfg: don't deallocate this while the service is in use
  (make-rehash-handle pointer cfg)
  rehash-handle?
  (pointer rehash-handle->pointer rehash-handle-pointer-set!)
  (cfg %rehash-handle-cfg rehash-handle-cfg-set!))

(define-record-type <query-context>
  (make-query-context pointer)
  query-context?
  (pointer query-context->pointer query-context-pointer-set!))

(define-record-type <store-context>
  (make-store-context pointer)
  store-context?
  (pointer store-context->pointer store-context-pointer-set!))

;; TODO perhaps rename to REHASH_query_abort
;; TODO may this be called from a callback?
(define query-abort!
  (aborter "REHASH_query_abort" query-context->pointer
           query-context-pointer-set!))
(define store-abort!
  (aborter "REHASH_store_abort" store-context->pointer
           store-context-pointer-set!))

(define open-rehash-service
  (let ((c:connect (delayed-ffi "REHASH_connect"
                                '*
                                '(*))))
    (lambda (config)
      "Connect to the rehash service.

Return a handle to the rehash service"
      (make-rehash-handle
       (or%
        (c:connect (unwrap-configuration config))
        (assert (and #f "invalid result from open-rehash-service")))
       config))))

(define close-rehash-service
  (let ((a (aborter "REHASH_disconnect" rehash-handle->pointer
                    rehash-handle-pointer-set!)))
    (lambda (handle)
      (a handle)
      (rehash-handle-cfg-set! handle #f))))

(define rehash-service-connected?
  (let ((c:connected (delayed-ffi "REHASH_connected"
                                  int
                                  '(*))))
    (lambda (h)
      "Check if @var{h} is conected to the rehash service

@param h handle to the rehash service
Returns #t if connected, #f otherwise"
      (define p (rehash-handle->pointer h))
      (assert (not (null-pointer? p)))
      (int->bool (c:connected p)))))

(define rehash-service-retry-connect
  (let ((c:retry-connect (delayed-ffi "REHASH_retry_connect"
                                  void
                                  '(*))))
    (lambda (h)
      "If @var{h} isn't connected yet / anymore to the rehash service,
retry.

@param h handle to the rehash service"
      (define p (rehash-handle->pointer h))
      (assert (not (null-pointer? p)))
      (c:retry-connect p))))

(define ORIGIN_DHT 0)
(define ORIGIN_DATASTORE 1)

(define (bytevector->hash type bv offset length)
  ;; internal format
  ;; TODO perhaps copy bv
  ;; bv is considered immutable
  ;; TODO asserts offset <= length etc.
  (assert (<= (+ offset length)
              (bytevector-length bv)))
  `#(,type ,bv ,offset ,length))
(define hash-type (cute vector-ref <> 0))

(define (hash-pointer h)
  (let* ((bv (vector-ref h 1))
         (offset (vector-ref h 2)))
    (bytevector->pointer bv offset)))

(define (hash-bv h)
  (pointer->bytevector (hash-pointer h) (hash-length h)))

(define hash-length (cute vector-ref <> 3))

;; TODO perhaps no literal numbers
(define HASH_NONE 0)
(define HASH_SHA256 1)
(define HASH_SHA512 2)
(define HASH_SHA3_256 3)
(define HASH_SHA3_512 4)
(define HASH_BLAKE2S_256 5)
(define HASH_FS_REGULAR 6)

(define store-continuation
  (procedure->pointer
   void
   (lambda (cls-pointer)
     (let ((callback (pointer->scm cls-pointer)))
       (and callback (callback))))
   '(*)))

(define store-hash!
  (let ((c:store! (delayed-ffi "REHASH_store_start"
                               '*
                               `(* * ,int ,int * ,size_t * ,size_t * *))))
    (lambda* (h input output
                #:key (when-done #f)
                (expiration-time #f)
                (anonymity-level #f)
                (content-priority #f)
                (replication-level #f))
      "Store an hash->hash mapping into the data store
 (and DHT, anonymity permitting), to be shared with
 other peers. If the entry is already present, the old
 entry is considered faulty and is replaced with the
 new mapping.

The callback @var{when-done} may be called from C and should terminate
quickly.

@param h handle to the rehash store
@param input hash to query with
@param output hash to find
@param when-done callback callback for when the hash->hash mapping
has been found, or @code{#f} to ignore such events
@return handle to abort the request"
      (let ((p (c:store! (rehash-handle->pointer h)
                         ;; TODO reasonable defaults
                         ;; defaults copied from (gnu gnunet fs)
                         (make-block-options expiration-time
                                             anonymity-level
                                             #:content-priority
                                             (or content-priority 365)
                                             #:replication-level
                                             (or replication-level 1))
                         (hash-type input)
                         (hash-type output)
                         (hash-pointer input)
                         (hash-length input)
                         (hash-pointer output)
                         (hash-length output)
                         store-continuation
                         (scm->pointer when-done))))
        (assert (not (null-pointer? p)))
        (make-store-context p)))))

(define-record-type <query-result>
  (make-query-result expires origin found-hash)
  query-result?
  ;; TODO: uint64_t or a SRFI time type?
  (expires query-result-expires)
  (origin query-result-origin)
  (found-hash query-result-found-hash))

(define (from-dht? query-result)
  (= (query-result-origin query-result)
     ORIGIN_DHT))
(define (from-datastore? query-result)
  (= (query-result-origin query-result)
     ORIGIN_DATASTORE))

(define (query-closure when-found out-type)
  (scm->pointer #`(,when-found ,type)))

(define (copy-mem-to-bv p offset length)
  (let ((pbv (pointer->bytevector p offset length)))
    (bytevector-copy pbv)))

(define query-continuation
  (procedure->pointer
   void
   (lambda (cls exp origin out-hash* out-length)
     (let* ((scheme-cls (pointer->scm cls))
            (when-found (vector-ref scheme-cls 0))
            (out-type   (vector-ref scheme-cls 1)))
       (if when-found
           (when-found
            (make-query-result
             exp origin
             (bytevector->hash out-type
                               (copy-mem-to-bv out-hash* 0 out-length)
                               0
                               out-length))))))
   `(* ,time-absolute ,int ,size_t *)))

(define query!
  (let ((c:query! (delayed-ffi "REHASH_query_start"
                               '*
                               `(* ,int ,uint32 ,int ,int * ,size_t * *))))
    (lambda* (h input output-type
                #:key (anonymity-level #f)
                (options    #f)
                (when-found #f))
      "Search for hash->hash mappings

@param h handle to rehash service
@param input hash to search with
@param output-type hash type to search for
@param anonymity anonymity levl (only 0 supported so far)
@param options TODO ???? 0
@param when-found callback to be called as @code{(callback query-result)}
with @var{query-result} of type <query-result>."
      (let ((p (c:query! (rehash-handle->pointer h)
                         ;; TODO maybe R6RS enum sets
                         ;; TODO some defaults
                         options
                         anonymity-level
                         (hash-type input)
                         output-type
                         (hash-pointer input)
                         (hash-length input)
                         query-continuation
                         (query-closure when-found output-type))))
        (assert (not (null-pointer? p)))
        (make-query-context p)))))
